home *** CD-ROM | disk | FTP | other *** search
/ PC-X 1997 October / pcx14_9710.iso / swag / parsing.swg / 0009_Pattern Matching and checking.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-05-27  |  13.3 KB  |  465 lines
  1.  
  2. UNIT match;
  3.  
  4.  (*  DESCRIPTION :
  5.   * 12 tests of character sets
  6.   * 8  new string operators
  7.   * Pattern matching  and mask checking
  8.  
  9.      RELEASE     :  2.0
  10.      DATE        :  09/08/93
  11.      AUTHOR      :  Fernand LEMOINE
  12.                     rue du Collège 34
  13.                     B-6200 CHATELET
  14.                     BELGIQUE
  15.      All code granted to the public domain
  16.      Questions and comments are welcome
  17.      REQUIREMENT :  Turbo Pascal 4.0 or later
  18.                     OPSTRING,OPABSFLD (Object Professional) from
  19.                        Turbo Power Software
  20.      Compatible with Borland Pascal protected mode
  21.   *)
  22.  
  23.  
  24. INTERFACE
  25. CONST
  26.   NullNumber = - MaxInt;      (* reserved for future use *)
  27.   BlankChar      : SET OF Char = [#32];
  28.   UpperOnlyset   : SET of Char = ['A'..'Z',#32,#128,#142..#144,
  29.                                   #153,#154,#165];
  30.   LowerOnlyset   : SET of Char = ['a'..'z',#32,#129..#141,#145,#147..#152,
  31.                                  #160..#164];
  32.   ForeignSet     : SET of Char = [#128..#154,#160..#167];
  33.   CntrlSet       : SET of Char = [#0..#31,#127];
  34.   PunctSet       : SET of Char = [#33,#39..#41,#44..#47,#58..#59,#63];
  35.   GraphicSet     : SET of Char = [#176..#223];
  36.   PrintOnlyset   : SET of Char = [#32..#126,#128..#254];
  37.   SpecificSet :    SET OF Char = []; (* must be modified by user *)
  38.   Delims :         SET OF Char = [' ', ',', '/'];
  39.   ProperSet :      SET OF Char = [' ', '-'];
  40.  
  41. TYPE
  42.   MatchOperator = (like, nsequal, between, not_between,
  43.                    into, not_into, pattern, mask);
  44.  
  45. (* Does the string S contain ONLY Alphabetic characters ? *)
  46. FUNCTION IsAlphabetic(S : String) : Boolean;
  47. (* Does the string S contain ONLY upper case characters ? *)
  48. FUNCTION IsUpperCase(S : String) : Boolean;
  49. (* Does the string S contain ONLY lower case characters ? *)
  50. FUNCTION IsLowerCase(S : String) : Boolean;
  51. (* Are the first characters of a name or a first name into S
  52.     a upper case  character,
  53.     and the others  lower case  characters ? *)
  54. FUNCTION IsMixedCase(S : String) : Boolean;
  55. (* Does the string S contain ONLY a space    character  ? *)
  56. FUNCTION IsSpace(S : String) : Boolean;
  57. (* Does the string S contain ONLY a null character ('') ? *)
  58. FUNCTION IsNullString(S : String) : Boolean;
  59. (* Does the string S contain ONLY a null     number     ? *)
  60. FUNCTION IsNullNumber(N : Real) : Boolean;
  61. (* Does the string S contain ONLY a number ('0'.. '9'   ? *)
  62. FUNCTION IsNumber(S : String) : Boolean;
  63. (* Does the string S contain ONLY number
  64.                                  space, minus and comma characters ? *)
  65. FUNCTION IsDigit(S : String) : Boolean;
  66. (* Does the string S contain ONLY number,space, minus and comma
  67.                                  'E' or 'e'  characters  ? *)
  68. FUNCTION IsScientific(S : String) : Boolean;
  69. (* Does the string S contain ONLY number and 'A'..'F' characters ? *)
  70. FUNCTION IsXdigit(S : String) : Boolean;
  71. (* Does the string S contain ONLY characters in an user-defined set ? *)
  72. FUNCTION IsSpecific(S : String) : Boolean;
  73.  
  74. (*      The string S is compared  with the string P  by a match operator :
  75.  
  76.     like        : phonetic comparison
  77.     nsequal     : not strictly equal ---> no difference between upper and
  78.                   lower case, neither trailing nor leading spaces
  79.     between     : between lower and upper limit
  80.     not_between : negation of BETWEEN
  81.     into        : selection in a value list
  82.     not_into    : negation of INTO
  83.     pattern     : matching a pattern with wildcards
  84.                   * : any single character
  85.                   ? : any series of characters
  86.                   ~ : NOT
  87.     mask;       : enables selected position of a field to be checked for a
  88.                   specific content
  89.       '-' : position that is not to be checked
  90.       'A' : check for alphabetic characters ( upper or lower case)
  91.       'a' : check for upper case alphabetic characters
  92.       'l' : check for lower case alphabetic characters
  93.       'K' : check for hexadecimal content
  94.       '@' : check for number;
  95.       '#' : check for digit;
  96.       'E' : check for number in exponential notation
  97.       'B' : check for blank
  98.       '%' : check for percent
  99.       'f' : check for foreign characters
  100.       'u' : check for punctuation ! ' ( ) , - . / : ; ?
  101.       'g' : check for semi-graphic characters
  102.       'o' : check for control characters
  103.       'p' : check for any printing characters
  104.       'B' : check for characters in BooleanSet
  105.       'Y' : check for characters in YesNoSet
  106.  *)
  107.  
  108. FUNCTION DMatch(S : String; op : MatchOperator; P : String) : Boolean;
  109.  
  110. IMPLEMENTATION
  111. USES opstring, opabsfld;
  112. VAR
  113.   tmp : Boolean;
  114.   errormask : Byte;
  115.  
  116.   (*-------------------------   String handling  ------------------------------------------------*)
  117.  
  118.   FUNCTION IsAlphabetic(S : String) : Boolean;
  119.   VAR
  120.     i : Byte;
  121.   BEGIN
  122.     tmp := True; i := 1;
  123.     WHILE (i <= Length(S)) AND tmp DO
  124.     BEGIN
  125.       tmp := S[i] IN AlphaOnlySet; Inc(i);
  126.     END;
  127.     IsAlphabetic := tmp;
  128.   END;
  129.  
  130.   FUNCTION IsUpperCase(S : String) : Boolean;
  131.   VAR
  132.     i : Byte;
  133.   BEGIN
  134.     tmp := True; i := 1;
  135.     WHILE (i <= Length(S)) AND tmp DO
  136.     BEGIN
  137.       tmp := S[i] IN UpperOnlyset; Inc(i);
  138.     END;
  139.     IsUpperCase := tmp;
  140.   END;
  141.  
  142.   FUNCTION IsLowerCase(S : String) : Boolean;
  143.   VAR
  144.     i : Byte;
  145.   BEGIN
  146.     tmp := True; i := 1;
  147.     WHILE (i <= Length(S)) AND tmp DO
  148.     BEGIN
  149.       tmp := S[i] IN LowerOnlyset; Inc(i);
  150.     END;
  151.     IsLowerCase := tmp;
  152.   END;
  153.  
  154.   FUNCTION IsMixedCase(S : String) : Boolean;
  155.   VAR
  156.     noword, nopos1, nopos2, i : Byte;
  157.     inter : String;
  158.   BEGIN
  159.     noword := WordCount(S, ProperSet);
  160.     tmp := True; i := 1;
  161.     WHILE (i <= noword) AND tmp DO
  162.     BEGIN
  163.       nopos1 := WordPosition(i, S, ProperSet);
  164.       IF i < noword THEN
  165.         nopos2 := (WordPosition(i + 1, S, ProperSet) - 2)
  166.       ELSE
  167.         nopos2 := Length(S);
  168.       inter := Copy(S, nopos1, nopos2);
  169.       tmp := IsUpperCase(inter[1]);
  170.       IF tmp THEN
  171.       BEGIN
  172.         Delete(inter, 1, 1);
  173.         tmp := IsLowerCase(inter);
  174.       END;
  175.       Inc(i, 1);
  176.     END;
  177.     IsMixedCase := tmp;
  178.   END;
  179.  
  180.   FUNCTION IsSpace(S : String) : Boolean;
  181.   BEGIN
  182.     IF S <> '' THEN
  183.       IsSpace := S = CharStr(' ', Length(S))
  184.     ELSE
  185.       IsSpace := False;
  186.   END;
  187.  
  188.   FUNCTION IsNullString(S : String) : Boolean;
  189.   BEGIN
  190.     IsNullString := S = '';
  191.   END;
  192.  
  193.  
  194.   FUNCTION IsNullNumber(N : Real) : Boolean;
  195.   BEGIN
  196.     IsNullNumber := N = NullNumber;
  197.   END;
  198.  
  199.   FUNCTION IsNumber(S : String) : Boolean;
  200.   VAR
  201.     i : Byte;
  202.   BEGIN
  203.     tmp := True; i := 1;
  204.     WHILE (i <= Length(S)) AND tmp DO
  205.     BEGIN
  206.       tmp := S[i] IN (NumberOnlySet - BlankChar); Inc(i);
  207.     END;
  208.     IsNumber := tmp;
  209.   END;
  210.  
  211.   FUNCTION IsDigit(S : String) : Boolean;
  212.   VAR
  213.     i : Byte;
  214.   BEGIN
  215.     tmp := True; i := 1;
  216.     WHILE (i <= Length(S)) AND tmp DO
  217.     BEGIN
  218.       tmp := S[i] IN DigitOnlySet; Inc(i);
  219.     END;
  220.     IsDigit := tmp;
  221.   END;
  222.  
  223.   FUNCTION IsScientific(S : String) : Boolean;
  224.   VAR
  225.     i : Byte;
  226.   BEGIN
  227.     tmp := True; i := 1;
  228.     WHILE (i <= Length(S)) AND tmp DO
  229.     BEGIN
  230.       tmp := S[i] IN ScientificSet; Inc(i);
  231.     END;
  232.     IsScientific := tmp;
  233.   END;
  234.  
  235.   FUNCTION IsXdigit(S : String) : Boolean;
  236.   VAR
  237.     i : Byte;
  238.   BEGIN
  239.     tmp := True; i := 1;
  240.     WHILE (i <= Length(S)) AND tmp DO
  241.     BEGIN
  242.       tmp := S[i] IN HexOnlySet; Inc(i);
  243.     END;
  244.     IsXdigit := tmp;
  245.   END;
  246.  
  247.   FUNCTION IsSpecific(S : String) : Boolean;
  248.   VAR
  249.     i : Byte;
  250.   BEGIN
  251.     tmp := True; i := 1;
  252.     WHILE (i <= Length(S)) AND tmp DO
  253.     BEGIN
  254.       tmp := S[i] IN SpecificSet; Inc(i);
  255.     END;
  256.     IsSpecific := tmp;
  257.   END;
  258.  
  259.   (*-------------------------   Pattern matching ------------------------------------------------*)
  260.  
  261.   FUNCTION DMatch(S : String; op : MatchOperator; P : String) : Boolean;
  262.   VAR
  263.     S1, S2, S3 : String;
  264.     Compar : compareType;
  265.     Ind, J, N, Nprime : Byte;
  266.     except : Boolean;
  267.  
  268.  
  269.     FUNCTION PtInterr(S, P : String) : Boolean;
  270.     VAR
  271.       tmp : Boolean;
  272.       i : Byte;
  273.  
  274.     BEGIN
  275.       tmp := True; i := 1;
  276.       WHILE (i <= Length(S)) AND tmp DO
  277.       BEGIN
  278.         IF P[i] <> '?' THEN
  279.         BEGIN
  280.           tmp := S[i] = P[i];
  281.         END;
  282.         Inc(i);
  283.       END;
  284.       PtInterr := tmp;
  285.     END;
  286.  
  287.     FUNCTION Aster(S, P : String) : Boolean;
  288.     VAR N : Byte;
  289.     BEGIN
  290.       tmp := True;
  291.       N := Pos('*', P);
  292.       IF N = 1 THEN
  293.       BEGIN
  294.         Delete(P, 1, 1);
  295.         tmp := PtInterr(Copy(S, Length(S) -
  296.                              Length(P) + 1, Length(P)), P);
  297.         Aster := tmp;
  298.       END;
  299.  
  300.       IF N = Length(P) THEN
  301.       BEGIN
  302.         Delete(P, Length(P), 1);
  303.         tmp := PtInterr(Copy(S, 1, Length(P)), P);
  304.         Aster := tmp;
  305.       END;
  306.     END;
  307.  
  308.  
  309.   BEGIN
  310.     tmp := True;
  311.     CASE op OF
  312.       like : DMatch := Soundex(S) = Soundex(P);
  313.       nsequal :
  314.         BEGIN
  315.           S1 := Trim(S); S2 := Trim(P);
  316.           Compar := CompUCString(S1, S2);
  317.           DMatch := Compar = equal;
  318.         END;
  319.       between :
  320.         BEGIN
  321.           N := WordPosition(2, P, Delims);
  322.           DMatch := (Copy(P, 1, N - 2) < S)
  323.           AND (S < Copy(P, N, (Length(P) - N + 1)));
  324.         END;
  325.       not_between :
  326.         BEGIN
  327.           N := WordPosition(2, P, Delims);
  328.           DMatch := (S < Copy(P, 1, N - 2))
  329.           OR (S > Copy(P, N, (Length(P) - N + 1)));
  330.         END;
  331.  
  332.       into :
  333.         BEGIN
  334.           tmp := False; J := 1;
  335.           Ind := WordCount(P, Delims);
  336.           WHILE (J <= Ind) AND NOT tmp DO
  337.           BEGIN
  338.             N := WordPosition(J, P, Delims);
  339.             IF J < Ind THEN
  340.             BEGIN
  341.               Nprime := WordPosition(J + 1, P, Delims);
  342.               tmp := S = Copy(P, N, Nprime - N - 1);
  343.             END
  344.             ELSE
  345.               tmp := S = Copy(P, N, (Length(P) - N + 1));
  346.             Inc(J);
  347.           END;
  348.           DMatch := tmp;
  349.         END;
  350.  
  351.       not_into :
  352.         BEGIN
  353.           tmp := True; J := 1;
  354.           Ind := WordCount(P, Delims);
  355.           WHILE (J <= Ind) AND tmp DO
  356.           BEGIN
  357.             N := WordPosition(J, P, Delims);
  358.             IF J < Ind THEN
  359.             BEGIN
  360.               Nprime := WordPosition(J + 1, P, Delims);
  361.               tmp := S <> Copy(P, N, Nprime - N - 1);
  362.             END
  363.             ELSE
  364.               tmp := S <> Copy(P, N, (Length(P) - N + 1));
  365.             Inc(J);
  366.           END;
  367.           DMatch := tmp;
  368.         END;
  369.  
  370.       pattern :
  371.         BEGIN
  372.  
  373.           except := Copy(P, 1, 1) = '~';
  374.           IF except THEN Delete(P, 1, 1);
  375.           N := Pos('*', P);
  376.           Nprime := Pos('*', Copy(P, N + 1, Length(P) - N)) + N;
  377.           IF Nprime > N THEN
  378.             tmp := Pos(Copy(P, N + 1, Nprime - N - 1), S) <> 0
  379.           ELSE
  380.             IF Pos('*', P) <> 0 THEN
  381.               tmp := Aster(S, P)
  382.           ELSE
  383.             IF Pos('?', P) <> 0 THEN
  384.               tmp := PtInterr(S, P)
  385.           ELSE
  386.             tmp := S = P;
  387.           IF except THEN DMatch := NOT tmp
  388.           ELSE DMatch := tmp;
  389.         END;
  390.  
  391.       mask :
  392.         BEGIN
  393.           tmp := True; J := 1; errormask := 0;
  394.           WHILE (J <= Length(P)) AND tmp DO
  395.           BEGIN
  396.             CASE P[J] OF
  397.               '-' : BEGIN END;
  398.               'A' : tmp := S[J] IN AlphaOnlySet;
  399.               'a' : tmp := S[J] IN UpperOnlyset;
  400.               'l' : tmp := S[J] IN LowerOnlyset;
  401.               'K' : tmp := S[J] IN HexOnlySet;
  402.               '@' : tmp := S[J] IN NumberOnlySet - BlankChar;
  403.               '#' : tmp := S[J] IN DigitOnlySet;
  404.               'E' : tmp := S[J] IN ScientificSet;
  405.               'B' : tmp := S[J] IN BlankChar;
  406.               '%' : tmp := S[J] = '%';
  407.               'f' : tmp := S[J] IN ForeignSet;
  408.               'u' : tmp := S[J] IN PunctSet;
  409.               'g' : tmp := S[J] IN GraphicSet;
  410.               'o' : tmp := S[J] IN CntrlSet;
  411.               'p' : tmp := S[J] IN PrintOnlyset;
  412.               'B' : tmp := S[J] IN BooleanSet;
  413.               'Y' : tmp := S[J] IN YesNoSet;
  414.             END;
  415.             IF tmp = False THEN errormask := J;
  416.             Inc(J);
  417.           END;
  418.           DMatch := tmp;
  419.         END;
  420.     END;
  421.   END;
  422.  
  423. END.
  424.  
  425. {  ----------------  DEMO PROGRAM ------------- }
  426.  
  427. program demmatch;
  428. (* Demonstration program for use of match unit *)
  429.  
  430. uses crt,match;
  431. var
  432.  
  433.   S,S1,S2  : string;
  434.   OK : boolean;
  435.  
  436.  
  437. begin
  438.   clrscr;
  439.   S := 'Jean Lemonier';
  440.   Writeln('Demo match unit ');writeln;
  441.   Writeln (' Jean Lemonier');
  442.   Writeln ('Alphabetic ? ',IsAlphabetic (S));
  443.   Writeln ('Upper case ? ',IsUpperCase  (S));
  444.   Writeln ('Mixed case ? ',IsMixedcase  (S));
  445.  
  446.   Writeln;
  447.   Writeln( '154.5');writeln;
  448.   S2 :=  '154.5';
  449.   Writeln ('Number ? ',IsNumber (S2));
  450.   Writeln ('Digit  ? ',IsDigit  (S2));
  451.  
  452.   S1:= ' Jean LEMONIER  '; S2 := 'Je';
  453.   Writeln;
  454.   Writeln('Equivalent ',S, ' ',S1 ,'? ',Dmatch(S,nsequal,S1));
  455.   Writeln('Je*,pattern,',s, '? ',Dmatch(S,pattern,'Je*'));
  456.   Writeln('De*,pattern,',s, '? ',Dmatch(S,pattern,'De*'));
  457.   Writeln('*er,pattern,',s, '? ',Dmatch(S,pattern,'*er'));
  458.   Writeln('????? Lemonier,pattern,',s, '? ',
  459.           Dmatch(S,pattern,'????? Lemonier'));
  460.   Writeln('???? Lemonier,pattern,',s, '? ',
  461.           Dmatch(S,pattern,'???? Lemonier'));
  462.   Writeln('ll,mask ',s2, '? ',Dmatch(S2,mask,'ll'));
  463.   Writeln('al,mask ',s2, '? ',Dmatch(S2,mask,'al'));
  464.   delay(2500);
  465. end.